home *** CD-ROM | disk | FTP | other *** search
/ FishMarket 1.0 / FishMarket v1.0.iso / fishies / 551-575 / disk_556 / scheme2c / scheme-src.lzh / scrt / scrt5.sc < prev    next >
Text File  |  1991-10-11  |  18KB  |  524 lines
  1. ;;;  SCHEME->C Runtime Library
  2.  
  3. ;*              Copyright 1989 Digital Equipment Corporation
  4. ;*                         All Rights Reserved
  5. ;*
  6. ;* Permission to use, copy, and modify this software and its documentation is
  7. ;* hereby granted only under the following terms and conditions.  Both the
  8. ;* above copyright notice and this permission notice must appear in all copies
  9. ;* of the software, derivative works or modified versions, and any portions
  10. ;* thereof, and both notices must appear in supporting documentation.
  11. ;*
  12. ;* Users of this software agree to the terms and conditions set forth herein,
  13. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  14. ;* right and license under any changes, enhancements or extensions made to the
  15. ;* core functions of the software, including but not limited to those affording
  16. ;* compatibility with other hardware or software environments, but excluding
  17. ;* applications which incorporate this software.  Users further agree to use
  18. ;* their best efforts to return to Digital any such changes, enhancements or
  19. ;* extensions that they make and inform Digital of noteworthy uses of this
  20. ;* software.  Correspondence should be provided to Digital at:
  21. ;* 
  22. ;*                       Director of Licensing
  23. ;*                       Western Research Laboratory
  24. ;*                       Digital Equipment Corporation
  25. ;*                       100 Hamilton Avenue
  26. ;*                       Palo Alto, California  94301  
  27. ;* 
  28. ;* This software may be distributed (but not offered for sale or transferred
  29. ;* for compensation) to third parties, provided such third parties agree to
  30. ;* abide by the terms and conditions of this notice.  
  31. ;* 
  32. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  33. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  34. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  35. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  36. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  37. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  38. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  39. ;* SOFTWARE.
  40.  
  41. (module scrt5
  42.     (top-level
  43.         STDIN-PORT STDOUT-PORT STDERR-PORT
  44.     CALL-WITH-INPUT-FILE CALL-WITH-OUTPUT-FILE INPUT-PORT? OUTPUT-PORT?
  45.     CURRENT-INPUT-PORT CURRENT-OUTPUT-PORT
  46.     WITH-INPUT-FROM-FILE WITH-OUTPUT-TO-FILE
  47.     OPEN-INPUT-FILE OPEN-OUTPUT-FILE OPEN-FILE MAKE-FILE-PORT
  48.     OPEN-INPUT-STRING OPEN-OUTPUT-STRING
  49.     CLOSE-INPUT-PORT CLOSE-OUTPUT-PORT CLOSE-PORT
  50.     DEFINE-SYSTEM-FILE-TASK WAIT-SYSTEM-FILE ENABLE-SYSTEM-FILE-TASKS))
  51.  
  52. ;;; 6.10.  Input and Output
  53. ;;;
  54. ;;; All I/O is done to and from "ports", where a port is an object that can
  55. ;;; read and write characters.  A port is represented as  (PORT . proc)
  56. ;;; where the symbol "PORT" identifies the object, and the procedure "proc"
  57. ;;; implements the operations.  This is but one example where closures provide
  58. ;;; an elegant, simple solution.  Needless to say, if a more general object
  59. ;;; based system is later implemented, the I/O system should be rewritten
  60. ;;; using it.
  61. ;;;
  62. ;;; The function MAKE-STRING-PORT makes a port which allows expressions to be
  63. ;;; read from a string, and MAKE-FILE-PORT makes a port which allows
  64. ;;; expressions to be read from a file.  Each time an I/O operation is done,
  65. ;;; the port's procedure is invoked.  It is called with a symbol which is the
  66. ;;; method needed and a procedure which performs that method is returned.  That
  67. ;;; procedure is then called with the appropriate arguments to perform the
  68. ;;; operation and return the result.  If the desired method does not exist,
  69. ;;; then #F should be returned.  The required methods for all ports are:
  70. ;;;
  71. ;;;  METHOD     ARGUMENTS         OPERATION & RESULT
  72. ;;;
  73. ;;; CLOSE-PORT    -        close port for all I/O, result is unspecified
  74. ;;;
  75. ;;; If the port supports input, then it must provide the following methods:
  76. ;;;
  77. ;;; READ-CHAR      -        next input character or EOF-OBJECT
  78. ;;; PEEK-CHAR     -        "peek" at the next character, or EOF-OBJECT
  79. ;;; CHAR-READY?      -        boolean indicating that an input character is
  80. ;;;                available
  81. ;;;
  82. ;;; Ports which support output must provide the following methods:
  83. ;;;
  84. ;;; WRITE-CHAR    character     output the character, result is unspecified
  85. ;;; WRITE-TOKEN      token        output the token (character, string, or list
  86. ;;;                of characters).  If the token will not fit
  87. ;;;                in the current line, then it will start a new
  88. ;;;                line.
  89. ;;; WRITE-WIDTH   -        number of characters per line
  90. ;;; WRITE-WIDTH!  number    sets the number of characters per line, result
  91. ;;;                is unspecified
  92. ;;; WRITE-COUNT      -        number of characters on current line
  93. ;;; WRITE-FLUSH   -        flush buffers, result is unspecified
  94. ;;;
  95. ;;; Some ports support the following additional methods:
  96. ;;;
  97. ;;; ECHO      -             port that I/O is echoed to (or #f)
  98. ;;; ECHO!      port/#F    sets I/O echo port
  99. ;;; FILE-PORT      -        Stdio library FILE for the port.
  100.  
  101. ;;; External declarations for Standard I/O Subroutines
  102.  
  103. (define-c-external STDIN pointer "sc_stdin")
  104.  
  105. (define-c-external STDOUT pointer "sc_stdout")
  106.  
  107. (define-c-external STDERR pointer "sc_stderr")
  108.  
  109. (define-c-external (FOPEN pointer pointer) pointer "fopen")
  110.  
  111. (define-c-external (FCLOSE pointer) int "fclose")
  112.  
  113. (define-c-external (FFLUSH pointer) int "fflush")
  114.  
  115. (define-c-external (FILENO pointer) int "sc_fileno")
  116.  
  117. (define-c-external (FGETC pointer) int "fgetc")
  118.  
  119. (define-c-external (CLEARERR pointer) int "sc_clearerr")
  120.  
  121. (define-c-external (FEOF pointer) int "sc_feof")
  122.  
  123. (define-c-external (FERROR pointer) int "sc_ferror")
  124.  
  125. (define-c-external (FPUTC int pointer) int "fputc")
  126.  
  127. (define-c-external (INPUT-CHARS? pointer) int "sc_inputchars")
  128.  
  129. (define-c-external (BUFFERED-CHARS? pointer) int "sc_bufferedchars")
  130.  
  131. (define-c-external ERRNO int "errno")
  132.  
  133. (define-c-external LIBC-EOF int "sc_libc_eof")
  134.  
  135. (define-c-external (SELECT int pointer pointer pointer pointer) int "select")
  136.  
  137. ;;; 6.10.1  Ports
  138.  
  139. (define (CALL-WITH-INPUT-FILE filename proc)
  140.     (if (not (procedure? proc))
  141.     (error 'CALL-WITH-INPUT-FILE "Argument is not a PROCEDURE: ~s" proc))
  142.     (let* ((port (open-file filename "r"))
  143.        (result (proc port)))
  144.       (close-port port)
  145.       result))
  146.  
  147. (define (CALL-WITH-OUTPUT-FILE filename proc)
  148.     (if (not (procedure? proc))
  149.         (error 'CALL-WITH-OUTPUT-FILE "Argument is not a PROCEDURE: ~s" proc))
  150.     (let* ((port (open-file filename "w"))
  151.        (result (proc port)))
  152.       (close-port port)
  153.       result))
  154.  
  155. (define (INPUT-PORT? x)
  156.     (if (and (pair? x) (eq? (car x) 'port) (procedure? (cdr x))
  157.          ((cdr x) 'read-char))
  158.     #t
  159.     #f))
  160.  
  161. (define (OUTPUT-PORT? x)
  162.     (if (and (pair? x) (eq? (car x) 'port) (procedure? (cdr x))
  163.          ((cdr x) 'write-char))
  164.     #t
  165.     #f))
  166.  
  167. ;;; The current input and output ports are kept in the following two cells.
  168. ;;; Initially the input port uses stdin and the output port uses stdout.
  169.  
  170. (define CURRENT-INPUT-PORT-VALUE (make-file-port stdin "r"))
  171.  
  172. (define CURRENT-OUTPUT-PORT-VALUE (make-file-port stdout "w"))
  173.  
  174. (define STDIN-PORT current-input-port-value)
  175.  
  176. (define STDOUT-PORT current-output-port-value)
  177.  
  178. (define STDERR-PORT (make-file-port stderr "w"))
  179.  
  180. (define (CURRENT-INPUT-PORT) current-input-port-value)
  181.  
  182. (define (CURRENT-OUTPUT-PORT) current-output-port-value)
  183.  
  184. (define (WITH-INPUT-FROM-FILE filename proc)
  185.     (let ((old-input-port (current-input-port))
  186.       (result '()))
  187.      (if (not (procedure? proc))
  188.          (error 'WITH-INPUT-FROM-FILE "Argument is not a PROCEDURE: ~s"
  189.             proc))
  190.      (set! current-input-port-value (open-file filename "r"))
  191.      (set! result (proc))
  192.      (close-port current-input-port-value)
  193.      (set! current-input-port-value old-input-port)
  194.      result))
  195.  
  196. (define (WITH-OUTPUT-TO-FILE filename proc)
  197.     (let ((old-output-port (current-output-port))
  198.       (result '()))
  199.      (if (not (procedure? proc))
  200.          (error 'WITH-OUTPUT-TO-FILE "Argument is not a PROCEDURE: ~s"
  201.             proc))
  202.      (set! current-output-port-value (open-file filename "w"))
  203.      (set! result (proc))
  204.      (close-port current-output-port-value)
  205.      (set! current-output-port-value old-output-port)
  206.      result))
  207.  
  208. (define (OPEN-INPUT-FILE filename) (open-file filename "r"))
  209.  
  210. (define (OPEN-OUTPUT-FILE filename) (open-file filename "w"))
  211.  
  212. ;;; The following function does the actual file opening.  It uses UNIX's fopen
  213. ;;; and supports the various open types.  See the man page fopen(3s) for
  214. ;;; more information.  The filename and type are expected to be strings and the
  215. ;;; return value of the function is a port.
  216.  
  217. (define (OPEN-FILE filename type)
  218.     (let ((file '()))
  219.      (if (not (string? filename))
  220.          (error 'FILENAME->FILE "Argument is not a STRING: ~s" filename))
  221.      (set! file (fopen filename type))
  222.      (if (zero? file)
  223.          (error 'FILENAME->FILE "Unable to open file ~s" filename))
  224.      (let ((port (make-file-port file type)))
  225.           (when-unreferenced port close-port)
  226.           port)))
  227.  
  228. ;;; The following function is used to make a port which is does I/O to a UNIX
  229. ;;; file.  It takes a file pointer (as a Scheme number) and the type string
  230. ;;; that was used to fopen the file initially.
  231.  
  232. (define (MAKE-FILE-PORT file type)
  233.     (letrec ((charcnt 0)
  234.          (width 80)
  235.          (echo-port #f)
  236.          (nextchar #f)
  237.  
  238.          (write-char (lambda (char)
  239.                  (if (char<? char #\space)
  240.                      (cond ((memq char
  241.                           '(#\linefeed #\return
  242.                             #\newline))
  243.                         (set! charcnt 0))
  244.                        ((eq? char #\tab)
  245.                         (set! charcnt
  246.                           (+ charcnt
  247.                              (- 8
  248.                             (remainder charcnt
  249.                                        8)))))
  250.                        (else (set! charcnt (+ charcnt 1))))
  251.                      (set! charcnt (+ charcnt 1)))
  252.                  (if (eq? (fputc (char->integer char) file)
  253.                       libc-eof)
  254.                      (error 'MAKE-FILE-PORT
  255.                         "I/O error ~s on output"
  256.                         (ferror file)))))
  257.  
  258.          (write-token (lambda (token)
  259.                   (cond ((char? token)
  260.                      (write-char token))
  261.                     ((or (pair? token) (null? token))
  262.                      (for-each write-char token))
  263.                     (else
  264.                      (let ((len (string-length token)))
  265.                           (do ((i 0 (+ i 1)))
  266.                           ((= i len))
  267.                           (write-char
  268.                               (string-ref
  269.                               token i))))))))
  270.  
  271.          (read-char (lambda ()
  272.                 (cond (nextchar
  273.                        (let ((c nextchar))
  274.                         (set! nextchar #f)
  275.                         c))
  276.                       (else
  277.                        (if (and (not (eq? system-file-mask 0))
  278.                                 (eq? (buffered-chars? file) 0))
  279.                        (wait-system-file (fileno file)))
  280.                        (let ((char (fgetc file)))
  281.                         (if (eq? char libc-eof)
  282.                         (if (feof file)
  283.                             (begin (clearerr file)
  284.                                $_eof-object)
  285.                             (error 'MAKE-FILE-PORT
  286.                              "I/O error ~s on port"
  287.                              (ferror file)))
  288.                         (integer->char char)))))))
  289.  
  290.          (peek-char (lambda ()
  291.                 (if nextchar
  292.                     nextchar
  293.                     (set! nextchar (read-char)))))
  294.  
  295.          (read-char-echo (lambda ()
  296.                      (let ((char (read-char)))
  297.                       (if (not (eof-object? char))
  298.                           (((cdr echo-port) 'write-char)
  299.                            char))
  300.                       char)))
  301.  
  302.          (char-ready? (lambda ()
  303.                   (if (or nextchar (eq? (input-chars? file) 1))
  304.                       #t
  305.                       #f)))
  306.  
  307.          (close-port (lambda ()
  308.                  (fflush file)
  309.                  (fclose file)))
  310.  
  311.          (write-char-echo (lambda (char)
  312.                       (write-char char)
  313.                       (((cdr echo-port) 'write-char) char)))
  314.  
  315.          (write-token-echo (lambda (token)
  316.                        (write-token token)
  317.                        (((cdr echo-port) 'write-token) token)))
  318.  
  319.          (write-count (lambda () charcnt))
  320.  
  321.          (write-width (lambda () width))
  322.  
  323.          (write-width! (lambda (w) (set! width w)))
  324.  
  325.          (write-flush (lambda () (fflush file)))
  326.  
  327.          (echo (lambda () echo-port))
  328.  
  329.          (echo! (lambda (p) (set! echo-port p)))
  330.  
  331.          (file-port (lambda () file)))
  332.  
  333.      (cond ((equal? type "r")
  334.         (set! write-char-echo #f)
  335.         (set! write-char #f))
  336.            ((equal? type "w")
  337.         (set! read-char-echo #f)
  338.         (set! read-char #f)))         
  339.      (cons 'port
  340.            (lambda (method)
  341.                (case method
  342.                      ((close-port)     close-port)
  343.                  ((read-char)      (if echo-port
  344.                            read-char-echo
  345.                            read-char))
  346.                  ((peek-char)      peek-char)
  347.                  ((char-ready?)    char-ready?)
  348.                  ((write-char)     (if echo-port
  349.                            write-char-echo
  350.                            write-char))
  351.                  ((write-token)    (if echo-port
  352.                            write-token-echo
  353.                            write-token))
  354.                  ((write-width)    write-width)
  355.                  ((write-width!)   write-width!)
  356.                  ((write-count)    write-count)
  357.                  ((write-flush)    write-flush)
  358.                  ((echo)            echo)
  359.                  ((echo!)           echo!)
  360.                  ((file-port)      file-port)
  361.                  (else #f))))))
  362.  
  363. ;;; The following function turns a string into an input port and thus allows
  364. ;;; Scheme expressions to be read from strings.  It is as defined in Chez
  365. ;;; Scheme.
  366.     
  367. (define (OPEN-INPUT-STRING string)
  368.     (letrec ((nextchar 0)
  369.          (strlen   (string-length string))
  370.  
  371.          (read-char (lambda ()
  372.                 (if (= nextchar strlen)
  373.                     $_eof-object
  374.                     (let ((char
  375.                            (string-ref string nextchar)))
  376.                      (set! nextchar (+ 1 nextchar))
  377.                      char))))
  378.          
  379.          (peek-char (lambda () (if (= nextchar strlen)
  380.                        $_eof-object
  381.                        (string-ref string nextchar))))
  382.          (true (lambda () #t)))
  383.         
  384.         (cons 'port
  385.           (lambda (method)
  386.               (case method
  387.                 ((read-char)   read-char)
  388.                 ((peek-char)   peek-char)
  389.                 ((char-ready?) true)
  390.                 ((close-port)  true)
  391.                 (else #f))))))
  392.  
  393. ;;; The following function is used to make a port which does I/O to a string.
  394. ;;; It is as defined in Chez Scheme.
  395.  
  396. (define (OPEN-OUTPUT-STRING)
  397.     (letrec ((chars '())
  398.          (width 80)
  399.  
  400.          (write-token (lambda (token)
  401.                   (cond ((char? token)
  402.                      (set! chars (cons token chars)))
  403.                     ((or (pair? token) (null? token))
  404.                      (set! chars
  405.                            (append (reverse token)
  406.                                chars)))
  407.                     (else
  408.                      (set! chars
  409.                            (append (reverse (string->list
  410.                                     token))
  411.                                chars))))))
  412.          (get-output-string (lambda ()
  413.                     (let ((s (list->string
  414.                              (reverse chars))))
  415.                          (set! chars '())
  416.                          s)))
  417.          
  418.          (write-char (lambda (char)
  419.                  (set! chars (cons char chars))))
  420.          
  421.          (write-width (lambda () width))
  422.  
  423.          (write-width! (lambda (w) (set! width w)))
  424.          
  425.          (write-count (lambda () (length chars))))
  426.         
  427.         (cons 'port
  428.           (lambda (method)
  429.               (case method
  430.                 ((write-token)       write-token)
  431.                 ((write-char)        write-char)
  432.                 ((write-width)       write-width)
  433.                 ((write-width!)      write-width!)
  434.                 ((write-count)       write-count)
  435.                 ((get-output-string) get-output-string)
  436.                 (else #f))))))
  437.  
  438. (define (CLOSE-INPUT-PORT port) (close-port port))
  439.  
  440. (define (CLOSE-OUTPUT-PORT port) (close-port port))
  441.  
  442. (define (CLOSE-PORT port)
  443.     (if (and (not (input-port? port)) (not (output-port? port)))
  444.     (error 'CLOSE-PORT "Argument is not a PORT: ~s" port))
  445.     (when-unreferenced port #f)
  446.     (((cdr port) 'close-port)))
  447.  
  448. ;;; When there are no characters available on a port, the I/O system executes
  449. ;;; the idle task associated with each system file and then dispatches system
  450. ;;; tasks or continues reading from the port when some read completes.  N.B:
  451. ;;;    (1) System file tasks never interrupt an executing Scheme program.
  452. ;;;    (2) System file tasking is disabled while in the debugger.
  453. ;;;    (3) All pending system file tasks are executed before continuing reads
  454. ;;;        from the port.
  455.  
  456. (define SYSTEM-TASKING #t)
  457.  
  458. (define SYSTEM-FILE-MASK 0)
  459.  
  460. (define MAX-SYSTEM-FILE -1)
  461.  
  462. (define SYSTEM-FILE-TASK #f)
  463.  
  464. (define IDLE-TASKS (make-vector 32 #f))
  465.  
  466. (define FILE-TASKS (make-vector 32 #f))
  467.  
  468. ;;; A task is associated with a system file number by the following procedure.
  469. ;;; A task is deleted by passing #F for each task procedure.
  470.  
  471. (define (DEFINE-SYSTEM-FILE-TASK file idle-task file-task)
  472.     (vector-set! idle-tasks file idle-task)
  473.     (vector-set! file-tasks file file-task)
  474.     (set! system-file-mask 0)
  475.     (set! max-system-file -1)
  476.     (do ((i 0 (+ 1 i)))
  477.     ((= i 32))
  478.     (when (vector-ref file-tasks i)
  479.           (set! max-system-file i)
  480.           (set! system-file-mask (bit-or system-file-mask (bit-lsh 1 i)))))
  481.     file)
  482.  
  483. ;;; A task waits for input on a file by calling the following procedure with
  484. ;;; the system file number, or #f.  When input is available on the file (<> #f)
  485. ;;; or all tasks have completed, the procedure returns.
  486.  
  487. (define (WAIT-SYSTEM-FILE file)
  488.     (if (and (not (eq? system-file-mask 0)) system-tasking)
  489.     (let ((x (make-string 4)))
  490.          (if (eq? file 0) (flush-buffer stdout-port))
  491.          (do ((i 0 (+ i 1)))
  492.          ((> i max-system-file))
  493.          (if (vector-ref idle-tasks i) ((vector-ref idle-tasks i))))
  494.          (c-unsigned-set! x 0
  495.          (bit-or system-file-mask (if file (bit-lsh 1 file) 0)))
  496.          (if (eq? (select (+ (max max-system-file (or file 0)) 1) x 0 0 0)
  497.               -1)
  498.          (if (eq? errno 4)
  499.              (wait-system-file file)
  500.              (error 'wait-system-file "Select error: ~s" errno)))
  501.          (let ((inputs (c-unsigned-ref x 0)))
  502.           (do ((i 0 (+ i 1))
  503.                (mask 1 (bit-lsh mask 1)))
  504.               ((> i max-system-file))
  505.               (if (not (eq? 0 (bit-and mask inputs)))
  506.               (let ((task (vector-ref file-tasks i)))
  507.                    (when task
  508.                      (set! system-file-task i)
  509.                      (task)))))
  510.           (set! system-file-task #f)
  511.           (if (or (not file) (zero? (bit-and inputs (bit-lsh 1 file))))
  512.               (wait-system-file file))))))
  513.  
  514. ;;; System file tasking is enabled and disabled by the following procedure.
  515. ;;; It returns the previous state of system file tasking.  When called with
  516. ;;; WAIT as its argument, it will not return until all system file tasks have
  517. ;;; completed.
  518.  
  519. (define (ENABLE-SYSTEM-FILE-TASKS enable)
  520.     (let ((prev system-tasking))
  521.      (set! system-tasking (if enable #t #f))
  522.      (if (eq? enable 'wait) (wait-system-file #f))
  523.      prev))
  524.